home *** CD-ROM | disk | FTP | other *** search
Text File | 1986-07-17 | 37.7 KB | 1,086 lines | [TEXT/ttxt] |
- $LINESIZE: 132
- $PAGESIZE: 61
- $STORAGE: 2
- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- C C
- C M I C R O S A F E C
- C Structural Analysis by Finite Elements C
- C Module : SAFESOLV, 2nd Part C
- C Version : 2-D C
- C C
- C COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986 C
- C ALL RIGHTS RESERVED C
- C C
- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- SUBROUTINE parsfn (flspec,ddrive,fldriv,driven,flpath,flname,
- + flextn)
- C
- C Parse a file specification and get drive, path, name and extension
- C
- IMPLICIT INTEGER (a-z)
- CHARACTER fldriv*6,flpath*64,flname*9,flextn*5,flspec*78,colon*2,
- + bslash*2,period*2
- C
- C Initialization.
- C
- call setstr (78,flspec)
- call pakstr (flspec)
- call upcstr (flspec)
- fldriv=' '
- call setstr (6,fldriv)
- flpath='
- + '
- call setstr (64,flpath)
- flname=' '
- call setstr (9,flname)
- flextn=' '
- call setstr (5,flextn)
- colon=': '
- call setstr (2,colon)
- bslash='\ '
- call setstr (2,bslash)
- period='. '
- call setstr (2,period)
- C
- C Determine the drive specification
- C
- locatn=locstr (1,flspec,colon)
- if (locatn .eq. 0) then
- driven=ddrive+1
- else
- call movstr (fldriv,1,1,flspec,1,locatn)
- driven=ascstr (locatn-1,flspec)-64
- endif
- C
- C Determine the path specification
- C
- firstc=locatn+1
- lastoc=locatn
- 10 locatn=locstr (lastoc+1,flspec,bslash)
- if (locatn .ne. 0) then
- lastoc=locatn
- goto 10
- else
- call movstr (flpath,1,1,flspec,firstc,lastoc-firstc+1)
- endif
- C
- C Determine the extension specification
- C
- length=lenstr(flspec)
- locatn=locstr (lastoc+1,flspec,period)
- if (locatn .ne. 0) then
- call movstr (flextn,1,1,flspec,locatn,length-locatn+1)
- else
- locatn=length+1
- endif
- C
- C Determine the name specification
- C
- call movstr (flname,1,1,flspec,lastoc+1,locatn-lastoc-1)
- C
- C Pack the return strings
- C
- call pakstr (fldriv)
- call pakstr (flpath)
- call pakstr (flname)
- call pakstr (flextn)
- RETURN
- END
- $PAGE
- SUBROUTINE triasemb (i,j,k,th,eyoung,pratio)
- C
- C Assemble stiffness matrix for triangular plate
- C
- DOUBLE PRECISION th,diffnc(2,4),ftcons(9),eyoung,pratio
- common /coordi/ coonod(2,401)
- diffnc(1,2)=coonod(1,J)-coonod(1,I)
- diffnc(2,2)=coonod(2,J)-coonod(2,I)
- diffnc(1,3)=coonod(1,K)-coonod(1,J)
- diffnc(2,3)=coonod(2,K)-coonod(2,J)
- diffnc(1,1)=coonod(1,I)-coonod(1,K)
- diffnc(2,1)=coonod(2,I)-coonod(2,K)
- ftcons(6)=diffnc(2,3)*diffnc(1,2)-diffnc(1,3)*diffnc(2,2)
- ftcons(1)=eyoung*TH/(4*ftcons(6))
- ftcons(8)=ftcons(1)/(1-pratio)
- ftcons(7)=ftcons(1)/(1+pratio)
- ftcons(1)=ftcons(7)*
- + (diffnc(1,3)*diffnc(1,3)+diffnc(2,3)*diffnc(2,3))
- ftcons(2)=ftcons(7)*
- + (diffnc(1,1)*diffnc(1,1)+diffnc(2,1)*diffnc(2,1))
- ftcons(3)=ftcons(7)*
- + (diffnc(1,3)*diffnc(1,2)+diffnc(2,3)*diffnc(2,2))
- ftcons(4)=ftcons(7)*ftcons(6)
- ftcons(5)=ftcons(7)*
- + (diffnc(1,2)*diffnc(1,2)+diffnc(2,2)*diffnc(2,2))
- I1=3*I-2
- J1=3*J-2
- K1=3*K-2
- CALL assemble (i1,i1,ftcons(1)+ftcons(8)*diffnc(2,3)*diffnc(2,3),
- + -ftcons(8)*diffnc(1,3)*diffnc(2,3),0.)
- CALL assemble (i1,j1,-ftcons(1)-ftcons(3)+
- + ftcons(8)*diffnc(2,3)*diffnc(2,1),
- + -ftcons(4)-ftcons(8)*diffnc(2,3)*diffnc(1,1),0.)
- CALL assemble (i1,k1,ftcons(3)+ftcons(8)*diffnc(2,2)*diffnc(2,3),
- + ftcons(4)-ftcons(8)*diffnc(2,3)*diffnc(1,2),0.)
- CALL assemble (i1+1,i1+1,ftcons(1)+
- + ftcons(8)*diffnc(1,3)*diffnc(1,3),0.,0.)
- CALL assemble (i1+1,J1,ftcons(4)-ftcons(8)*
- + diffnc(2,1)*diffnc(1,3),-ftcons(1)-ftcons(3)+
- + ftcons(8)*diffnc(1,1)*diffnc(1,3),0.)
- CALL assemble (i1+1,K1,
- + -ftcons(4)-ftcons(8)*diffnc(2,2)*diffnc(1,3),
- + ftcons(3)+ftcons(8)*diffnc(1,2)*diffnc(1,3),0.)
- CALL assemble (J1,j1,ftcons(2)+ftcons(8)*diffnc(2,1)*diffnc(2,1),
- + -ftcons(8)*diffnc(2,1)*diffnc(1,1),0.)
- CALL assemble (j1,K1,-ftcons(3)-ftcons(5)+
- + ftcons(8)*diffnc(2,1)*diffnc(2,2),
- + -ftcons(4)-ftcons(8)*diffnc(2,1)*diffnc(1,2),0.)
- CALL assemble (j1+1,j1+1,
- + ftcons(2)+ftcons(8)*diffnc(1,1)*diffnc(1,1),0.,0.)
- CALL assemble (j1+1,k1,ftcons(4)-
- + ftcons(8)*diffnc(1,1)*diffnc(2,2),-ftcons(3)-
- + ftcons(5)+ftcons(8)*diffnc(1,1)*diffnc(1,2),0.)
- CALL assemble (K1,K1,ftcons(5)+ftcons(8)*diffnc(2,2)*diffnc(2,2),
- + -ftcons(8)*diffnc(1,2)*diffnc(2,2),0.)
- CALL assemble (k1+1,k1+1,
- + ftcons(5)+ftcons(8)*diffnc(1,2)*diffnc(1,2),0.,0.)
- RETURN
- END
- $PAGE
- SUBROUTINE assemble (irow,icol,add1,add2,add3)
- C
- C Assemble the stiffness matrix
- C
- DOUBLE PRECISION stmtrx,stmqcn,add(3),add1,add2,add3
- INTEGER longi*4
- COMMON /global/ numdof,stmqcn(2,2)
- common /sizebw/ malhbw
- COMMON /aaaaaa/ stmtrx(8200)
- add(1)=add1
- add(2)=add2
- add(3)=add3
- do 10 i=1,3
- if (add(i) .ne. 0.) then
- ic=icol+i-1
- if ((irow .le. numdof) .and. (ic .le. numdof)) then
- longi=ic+irow-1-malhbw
- if (irow .ge. ic) then
- longi=longi+malhbw*ic
- else
- longi=longi+malhbw*irow
- endif
- stmtrx(longi)=stmtrx(longi)+add(i)
- else
- longi=ic+irow-2-numdof
- if (irow .gt. numdof) then
- if (ic .le. numdof) then
- longi=longi+ic*(malhbw+1)
- stmtrx(longi)=stmtrx(longi)+add(i)
- else
- ir=irow-numdof
- icband=ic-numdof
- stmqcn(ir,icband)=stmqcn(ir,icband)+add(i)
- stmqcn(icband,ir)=stmqcn(ir,icband)
- endif
- else
- longi=longi+irow*(malhbw+1)
- stmtrx(longi)=stmtrx(longi)+add(i)
- endif
- endif
- ENDIF
- 10 continue
- RETURN
- END
- $PAGE
- SUBROUTINE triloads (inp1,inp2,inp3,th,eyoung,pratio,lpl,nodepl)
- C
- C Calculate forces and stresses in triangular plate
- C
- DOUBLE PRECISION disdof,corfor,eyoung,pratio,th,
- + diffnc(2,4),ftcons(9)
- DIMENSION inp(3),corfor(2,3),nodepl(4,500)
- INTEGER previd
- common /coordi/ coonod(2,401)
- COMMON /plates/ disdof(1203),pltecf(2,4),plstrs(3,500),
- + reafor(3,400),pstnor(3,400),pstacc(3,400)
- previd(k,l)=MOD(k+l-2,l)+1
- nextid(k,l)=MOD(k,l)+1
- inp(1)=inp1
- inp(2)=inp2
- inp(3)=inp3
- I=nodepl(inp(1),LPL)
- J=nodepl(inp(2),LPL)
- IF (inp(3) .lt. 0) THEN
- K=-inp(3)
- nan=2
- ELSE
- K=nodepl(inp(3),LPL)
- nan=3
- ENDIF
- I1=3*I-2
- J1=3*J-2
- K1=3*K-2
- diffnc(1,2)=coonod(1,J)-coonod(1,I)
- diffnc(2,2)=coonod(2,J)-coonod(2,I)
- diffnc(1,3)=coonod(1,K)-coonod(1,J)
- diffnc(2,3)=coonod(2,K)-coonod(2,J)
- diffnc(1,1)=coonod(1,I)-coonod(1,K)
- diffnc(2,1)=coonod(2,I)-coonod(2,K)
- ftcons(4)=eyoung/((1+pratio)*(diffnc(1,1)*diffnc(2,2)-
- + diffnc(1,2)*diffnc(2,1)))
- ftcons(5)=diffnc(2,3)*disdof(I1)+diffnc(2,1)*disdof(J1)+
- + diffnc(2,2)*disdof(K1)
- ftcons(6)=diffnc(1,3)*disdof(I1+1)+diffnc(1,1)*disdof(J1+1)+
- + diffnc(1,2)*disdof(K1+1)
- ftcons(1)=(pratio*ftcons(6)-ftcons(5))*ftcons(4)/(1-pratio)
- ftcons(2)=(ftcons(6)-pratio*ftcons(5))*ftcons(4)/(1-pratio)
- ftcons(3)=(diffnc(1,3)*disdof(I1)-diffnc(2,3)*disdof(I1+1)+
- + diffnc(1,1)*disdof(J1)-diffnc(2,1)*disdof(J1+1)+
- + diffnc(1,2)*disdof(K1)-diffnc(2,2)*disdof(K1+1))*
- + ftcons(4)/2
- DO 20 LL=1,NAN
- INDX=nodepl(inp(LL),LPL)
- ftcons(7)=ABS(diffnc(2,nextid(LL,3))-diffnc(2,LL))/
- + (ABS(diffnc(1,nextid(LL,3))-diffnc(1,LL))+
- + ABS(diffnc(2,nextid(LL,3))-diffnc(2,LL)))
- DO 10 L=1,2
- corfor(L,LL)=TH*.5*(diffnc(1,previd(LL,3))*ftcons(4-L)-
- + diffnc(2,previd(LL,3))*ftcons(2*L-1))
- pltecf(L,inp(LL))=pltecf(L,inp(LL))+corfor(L,LL)
- ftcons(7)=1-ftcons(7)
- reafor(L,INDX)=reafor(L,INDX)+corfor(L,LL)
- pstnor(L,INDX)=pstnor(L,INDX)+ftcons(7)
- pstacc(L,INDX)=pstacc(L,INDX)+ftcons(7)*ftcons(L)
- 10 CONTINUE
- pstacc(3,INDX)=pstacc(3,INDX)+ftcons(3)
- pstnor(3,INDX)=pstnor(3,INDX)+1
- plstrs(LL,LPL)=plstrs(LL,LPL)+ftcons(LL)
- 20 CONTINUE
- IF (nan .EQ. 2) plstrs(3,LPL)=plstrs(3,LPL)+ftcons(3)
- RETURN
- END
- $PAGE
- SUBROUTINE opnfil (ierror)
- C
- C Open a file for output with verification
- C
- LOGICAL ffound
- CHARACTER inpfil*78,outfil*78,prompt*55,intgst*25
- common /filenm/ inpfil,outfil
- inquire (FILE=outfil,EXIST=ffound)
- if (.not.(ffound)) then
- call setstr (78,outfil)
- call pakstr (outfil)
- length=lenstr(outfil)+1
- call expstr (outfil)
- call resstr (outfil)
- call setstr (length,outfil)
- call chopwr (outfil,ierror)
- if (ierror .ne. 0) then
- call resstr (outfil)
- length=length-1
- call wrfstr (float(length),intgst)
- length=lenstr (intgst)
- prompt='('' ERROR : File "'',a ,''" cannot be open. Try a
- +gain.'') '
- call setstr (55,prompt)
- call movstr (prompt,21,0,intgst,1,length)
- call resstr (prompt)
- write (*,prompt) outfil
- return
- endif
- call resstr (outfil)
- endif
- OPEN (2,FILE=outfil,STATUS='new')
- ierror=0
- return
- END
- $PAGE
- SUBROUTINE diskroom (nbytes)
- C
- C Update count of characters in output file to avoid disk full errors.
- C
- INTEGER frespc*4,odrive,scrflg,asciic
- COMMON /dskrom/ scrflg,odrive
- C
- if (nbytes .eq. 0) then
- call dskspc (odrive,frespc)
- frespc=frespc-1
- else
- C
- 20 frespc=frespc-nbytes
- C
- if (frespc .lt. 0) then
- close (2)
- asciic=odrive+64
- write (*,30)
- 30 format (//' ERROR : Output file disk is full.')
- 32 write (*,35) char(asciic)
- 35 format (' Change the disk in drive ',a1,
- + ' and press any key to continue.')
- call confrm
- if (scrflg .eq. 0) write (*,40)
- 40 format (1x\)
- call opnfil (ierror)
- if (ierror .ne. 0) goto 32
- call dskspc (odrive,frespc)
- frespc=frespc-1
- goto 20
- endif
- endif
- return
- end
- $PAGE
- SUBROUTINE verify (idline,entry,ierror,maxban,youngm)
- C
- C Verify input data
- C
- implicit integer (a-z)
- real coonod,entry,boulow,bouhig,ftcons,fltstr,youngm
- CHARACTER buffer*126,slash*2,space*2,stcons*25,line*79,inpfil*78,
- + outfil*78,period*2,grafch*1,tabchr*2,typpar*14,ordinl*8,
- + errmsg*50,lintyp*16,linent*30,txtpar*49,messge*80
- DIMENSION numpar(14),itypar(14,8),boulow(14,8),bouhig(14,8),
- + itxtpr(14,8),typpar(2),errmsg(9),lintyp(14),linent(14),
- + ordinl(8),txtpar(40),messge(3),entry(8),youngm(20)
- common /coordi/ coonod(2,401)
- common /sizebw/ malhbw
- common /filenm/ inpfil,outfil
- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- C C
- C ARRAY INITIALIZATION C
- C C
- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- DATA numpar /1,1,1,1,1,1,1,3,3,8,7,5,4,3/
- DATA itypar /14*1,9*2,3*1,2,1,9*2,3*1,2,1,10*2,1,3*2,10*2,1,3*2,
- + 10*1,4*2,10*2,4*1,14*2/
- DATA boulow /1.,6*0.,7*1.,8*-10E18,0.,3*1.,-10E18,1.,8*-10E18,
- + 0.,3*1.,2*-10E18,10*0.,1.,0.,2*-10E18,14*0.,10*1.,
- + 4*0.,10*-10E18,4*1.,14*-10E18/
- DATA bouhig /400.,20.,600.,500.,60.,100.,300.,7*0.,13*10E18,3.,
- + 14*10E18,14*10E18,14*10E18,14*10E18,14*10E18,
- + 14*10E18/
- DATA typpar /' - an integer ',' - a number '/
- DATA errmsg /'UNEXPECTED END OF INPUT FILE. '
- + ,'INPUT LINE CONTAINS LESS DATA THAN REQUIRED. '
- + ,'ENTRY CANNOT BE INTERPRETED AS A NUMBER. '
- + ,'INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE. '
- + ,'ENTRY IS OUTSIDE THE PROPER NUMERIC BOUNDS. '
- + ,'THE STIFFNESS MATRIX BAND IS TOO WIDE. '
- + ,'ELEMENT WITH TWO IDENTICAL NODES. '
- + ,'ELEMENT NODES SHARE THE SAME PHYSICAL LOCATION. '
- + ,'DUPLICATED SPECIFICATIONS IN INPUT FILE. '/
- DATA lintyp /'model size '
- + ,'model size '
- + ,'model size '
- + ,'model size '
- + ,'model size '
- + ,'model size '
- + ,'model size '
- + ,'node '
- + ,'material '
- + ,'beam '
- + ,'plate '
- + ,'fastener '
- + ,'nodal loading '
- + ,'nodal restraint '/
- DATA linent /' '
- + ,' '
- + ,' '
- + ,' '
- + ,' '
- + ,' '
- + ,' '
- + ,'coordinates of node '
- + ,'properties of material code '
- + ,'properties of beam '
- + ,'properties of plate '
- + ,'properties of fastener '
- + ,'applied loads to node '
- + ,'imposed displacements to node '/
- DATA ordinl /'first '
- + ,'second '
- + ,'third '
- + ,'fourth '
- + ,'fifth '
- + ,'sixth '
- + ,'seventh '
- + ,'eighth '/
- DATA itxtpr /1,2,3,4,5,6,7,8,11,14,22,29,34,38,
- + 0,0,0,0,0,0,0,9,12,15,23,30,35,39,
- + 0,0,0,0,0,0,0,10,13,16,24,31,36,40,
- + 0,0,0,0,0,0,0,0,0,17,25,32,37,0,
- + 0,0,0,0,0,0,0,0,0,18,26,33,0,0,
- + 0,0,0,0,0,0,0,0,0,19,27,0,0,0,
- + 0,0,0,0,0,0,0,0,0,20,28,0,0,0,
- + 0,0,0,0,0,0,0,0,0,21,0,0,0,0/
- stcons=' '
- line='
- + '
- slash='/ '
- call setstr(2,slash)
- space=' '
- call setstr(2,space)
- grafch=char(9)
- tabchr=' '
- call setstr(2,tabchr)
- call movstr(tabchr,1,0,grafch,1,1)
- chrerr=0
- idparm=1
- locatn=1
- if (idline .eq. 1) linumb=0
- 10 linumb=linumb+1
- ierror=1
- READ (1,20,END=70,ERR=1000) buffer
- 20 FORMAT (A126)
- call setstr(126,buffer)
- ierror=0
- ENDSEP=locstr(1,buffer,slash)
- IF (ENDSEP .eq. 0) goto 10
- call endstr (endsep+1,buffer)
- 25 itcons=locstr(locatn,buffer,tabchr)
- if (itcons .ne. 0) then
- call movstr (buffer,itcons,0,space,1,1)
- locatn=itcons+1
- goto 25
- endif
- locatn=1
- 30 IF (locatn .ge. ENDSEP) THEN
- chrerr=ENDSEP
- ierror=2
- GOTO 70
- endif
- seprtr=locstr(locatn,buffer,space)
- IF (seprtr .eq. locatn) THEN
- locatn=locatn+1
- GOTO 30
- endif
- IF ((seprtr .eq. 0) .OR. (seprtr .gt. ENDSEP)) seprtr=ENDSEP
- ierror=0
- decpop=0
- EXPFLG=0
- EXPSGN=0
- seploc=seprtr-locatn
- do 50 positn=1,SEPLOC
- index=locatn+positn-1
- asciic=ascstr(index,buffer)
- IF ((asciic .gt. 47) .AND. (asciic .lt. 58)) goto 40
- IF ((positn .eq. 1) .AND. ((asciic .eq. 43) .OR.
- + (asciic .eq. 45))) goto 40
- IF ((asciic .eq. 46) .AND. (decpop .eq. 0)) THEN
- decpop=locatn+positn-1
- GOTO 40
- endif
- IF (((asciic .eq. 68) .OR. (asciic .eq. 69) .OR. (asciic .eq. 100)
- + .OR. (asciic .eq. 101)) .AND. (EXPFLG .eq. 0)) THEN
- EXPFLG=locatn+positn
- GOTO 40
- endif
- IF (((asciic .eq. 43) .OR. (asciic .eq. 45)) .AND. (EXPFLG .ne. 0)
- + .AND. (EXPSGN .eq. 0)) THEN
- EXPSGN=locatn+positn
- if (asciic .gt. 43) expsgn=-expsgn
- GOTO 40
- endif
- ierror=3
- chrerr=locatn+positn-1
- goto 60
- 40 continue
- 50 continue
- 60 continue
- IF (ierror .eq. 3) goto 70
- call setstr(25,stcons)
- call movstr(stcons,1,1,buffer,locatn,SEPLOC)
- call resstr(stcons)
- ftcons=fltstr(stcons)
- IF ((ftcons .lt. boulow(idline,idparm)) .OR.
- + (ftcons .gt. bouhig(idline,idparm))) THEN
- ierror=5
- chrerr=locatn
- GOTO 70
- endif
- IF ((itypar(idline,idparm) .eq. 1) .and.
- + (ftcons .ne. float(int(ftcons)))) then
- ierror=4
- IF (decpop .ne. 0) THEN
- chrerr=decpop
- GOTO 70
- ELSE
- IF (EXPSGN .lt. 0) THEN
- chrerr=-EXPSGN
- GOTO 70
- ELSE
- chrerr=locatn
- GOTO 70
- endif
- endif
- endif
- entry(idparm)=ftcons
- if ((idparm .eq. 1) .and. (idline .gt. 7) .and. (idline .lt. 14))
- + then
- itcons=INT(ftcons)
- CALL CHKDUP (itcons,ierror)
- IF (ierror .ne. 0) THEN
- ierror=9
- chrerr=locatn
- goto 70
- endif
- else
- if ((idparm .eq. 2) .and. (idline .eq. 14)) then
- itcons=INT(3*entry(1)+ftcons-3)
- CALL CHKDUP (itcons,ierror)
- IF (ierror .ne. 0) THEN
- ierror=9
- chrerr=locatn
- goto 70
- endif
- endif
- endif
- locatn=seprtr+1
- idparm=idparm+1
- IF (idparm .gt. numpar(idline)) THEN
- if (idline .lt. 6) bouhig(idline+7,1)=entry(1)
- if (idline .eq. 1) then
- bouhig(10,2)=entry(1)
- bouhig(10,3)=entry(1)
- bouhig(11,2)=entry(1)
- bouhig(11,3)=entry(1)
- bouhig(11,4)=entry(1)
- bouhig(11,5)=entry(1)
- bouhig(12,2)=entry(1)
- bouhig(12,3)=entry(1)
- bouhig(13,1)=entry(1)
- bouhig(14,1)=entry(1)
- endif
- if (idline .eq. 2) then
- bouhig(10,6)=entry(1)
- bouhig(11,7)=entry(1)
- endif
- if (((idline .eq. 10) .and. (entry(4) .ne. 0.) .and.
- + (youngm(int(entry(6))) .ne. 0.)) .or.
- + ((idline .eq. 12) .and. (entry(5) .ne. 0.))) then
- nod1=int(entry(2))
- nod2=int(entry(3))
- lbanwd=3*(1+abs(nod1-nod2))
- if (lbanwd .gt. malhbw) then
- ierror=6
- goto 70
- else
- if (lbanwd .eq. 3) then
- ierror=7
- goto 70
- endif
- endif
- if (idline .eq. 10) then
- if ((coonod(1,nod1) .eq. coonod(1,nod2)) .and.
- + (coonod(2,nod1) .eq. coonod(2,nod2))) then
- ierror=8
- goto 70
- endif
- endif
- if (lbanwd .gt. maxban) maxban=lbanwd
- else
- if ((idline .eq. 11) .and. (entry(6) .ne. 0.) .and.
- + (youngm(int(entry(7))) .ne. 0.)) then
- maxnod=max(int(entry(2)),int(entry(3)),
- + int(entry(4)))
- minnod=min(int(entry(2)),int(entry(3)),
- + int(entry(4)))
- if (entry(5) .ne. 0.) then
- maxnod=max(maxnod,int(entry(5)))
- minnod=min(minnod,int(entry(5)))
- endif
- lbanwd=3*(1+maxnod-minnod)
- if (lbanwd .gt. malhbw) then
- ierror=6
- goto 70
- endif
- do 65 itcons=2,4
- nod1=int(entry(itcons))
- startp=itcons+1
- do 65 index=startp,5
- nod2=int(entry(index))
- if (nod2 .ne. 0) then
- if (nod1 .eq. nod2) then
- ierror=7
- goto 70
- else
- if ((coonod(1,nod1) .eq. coonod(1,nod2)) .and.
- + (coonod(2,nod1) .eq. coonod(2,nod2))) then
- ierror=8
- goto 70
- endif
- endif
- endif
- 65 continue
- if (lbanwd .gt. maxban) maxban=lbanwd
- endif
- endif
- goto 3000
- ELSE
- goto 30
- endif
- 70 txtpar(1)='number of nodes in the model '
- txtpar(2)='number of types of materials in the model '
- txtpar(3)='number of beams in the model '
- txtpar(4)='number of plates in the model '
- txtpar(5)='number of fasteners in the model '
- txtpar(6)='number of loaded nodes in the model '
- txtpar(7)='number of restrained displacements in the model '
- txtpar(8)='node number '
- txtpar(9)='x coordinate of the node '
- txtpar(10)='y coordinate of the node '
- txtpar(11)='material number '
- txtpar(12)='Young''s modulus of the material '
- txtpar(13)='Poisson''s ratio of the material '
- txtpar(14)='beam number '
- txtpar(15)='index of the first node of the beam '
- txtpar(16)='index of the second node of the beam '
- txtpar(17)='beam area '
- txtpar(18)='beam moment of inertia '
- txtpar(19)='beam material code '
- txtpar(20)='distributed load at the first node of the beam '
- txtpar(21)='distributed load at the second node of the beam '
- txtpar(22)='plate number '
- txtpar(23)='index of the first node of the plate '
- txtpar(24)='index of the second node of the plate '
- txtpar(25)='index of the third node of the plate '
- txtpar(26)='index of the fourth node of the plate '
- txtpar(27)='plate thickness '
- txtpar(28)='plate material code '
- txtpar(29)='fastener number '
- txtpar(30)='index of the first node of the fastener '
- txtpar(31)='index of the second node of the fastener '
- txtpar(32)='fastener area '
- txtpar(33)='fastener stiffness '
- txtpar(34)='loaded node number '
- txtpar(35)='applied load at the node along the x direction '
- txtpar(36)='applied load at the node along the y direction '
- txtpar(37)='applied moment at the node along the z direction '
- txtpar(38)='node number with a restrained degree of freedom '
- txtpar(39)='restrained degree of freedom of the node '
- txtpar(40)='imposed displacement at the node '
- write (*,80) errmsg(ierror)
- 80 FORMAT (//' ERROR : ',A50)
- call diskroom (67)
- write (2,80,err=2000) errmsg(ierror)
- messge(1)='
- + '
- messge(2)='
- + '
- messge(3)='
- + '
- call setstr (240,MESSGE(1))
- stcons='Encountered '
- call movstr (messge(1),1,1,stcons,1,11)
- IF (ierror .eq. 1) THEN
- stcons=' attempting to read '
- ELSE
- stcons=' in '
- endif
- call setstr (25,stcons)
- call constr (messge(1),stcons)
- call pakstr (messge(1))
- stcons=' line '
- call setstr (6,stcons)
- call constr (messge(1),stcons)
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (float(linumb),stcons)
- call constr (messge(1),stcons)
- call pakstr (messge(1))
- stcons=' of file '
- call setstr (9,stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),space)
- call setstr (78,inpfil)
- call pakstr (inpfil)
- call constr (messge(1),inpfil)
- period='. '
- call setstr (2,period)
- call constr (messge(1),period)
- call writxt (messge)
- IF (ierror .eq. 1) goto 3000
- grafch=char(218)
- call setstr (79,line)
- call filstr (196,line)
- call movstr (line,1,0,grafch,1,1)
- if (chrerr .ne. 0) then
- grafch=char(25)
- call movstr (line,chrerr+1,0,grafch,1,1)
- endif
- length=lenstr (buffer)+2
- grafch=char(191)
- call movstr (line,length,0,grafch,1,1)
- length=length+1
- call endstr (length,line)
- call resstr (line)
- write (*,90) line
- 90 format (1x,A79)
- call diskroom (82)
- write (2,90,err=2000) line
- length=length-3
- call setstr (79,line)
- grafch=char(179)
- call movstr (line,1,0,grafch,1,1)
- call movstr (line,2,0,buffer,1,length)
- length=length+2
- call movstr (line,length,0,grafch,1,1)
- length=length+1
- call endstr (length,line)
- call resstr (line)
- write (*,90) line
- call diskroom (82)
- write (2,90,err=2000) line
- grafch=char(192)
- call setstr (79,line)
- call filstr (196,line)
- call movstr (line,1,0,grafch,1,1)
- if (chrerr .ne. 0) then
- grafch=char(24)
- call movstr (line,chrerr+1,0,grafch,1,1)
- endif
- length=lenstr (buffer)+2
- grafch=char(217)
- call movstr (line,length,0,grafch,1,1)
- length=length+1
- call endstr (length,line)
- call resstr (line)
- write (*,90) line
- call diskroom (82)
- write (2,90,err=2000) line
- call filstr (32,messge(1))
- if (ierror .eq. 6) then
- stcons=' The bandwidth for '
- call movstr (messge(1),1,0,stcons,1,18)
- call movstr (messge(1),20,0,lintyp(idline),1,16)
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (entry(1),stcons)
- call constr (messge(1),stcons)
- stcons=' is '
- call setstr (4,stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),space)
- call wrfstr (float(lbanwd),stcons)
- call constr (messge(1),stcons)
- stcons=' and exceeds the maximum '
- call setstr (25,stcons)
- call constr (messge(1),stcons)
- stcons=' allowed bandwidth of '
- call setstr (22,stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),space)
- call wrfstr (float(malhbw),stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),period)
- call writxt (messge)
- goto 3000
- endif
- if (ierror .eq. 7) then
- stcons=' There are identical node'
- call movstr (messge(1),1,0,stcons,1,25)
- call pakstr (messge(1))
- stcons='s in '
- call setstr (5,stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),space)
- call setstr (16,lintyp(idline))
- call constr (messge(1),lintyp(idline))
- call resstr (lintyp(idline))
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (entry(1),stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),period)
- call writxt (messge)
- goto 3000
- endif
- if (ierror .eq. 8) then
- stcons=' Nodes '
- call movstr (messge(1),1,0,stcons,1,6)
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (float(nod1),stcons)
- call constr (messge(1),stcons)
- stcons=' and '
- call setstr (5,stcons)
- call constr (messge(1),stcons)
- call constr (messge(1),space)
- call wrfstr (float(nod2),stcons)
- call constr (messge(1),stcons)
- stcons=' of '
- call setstr (5,stcons)
- call constr (messge(1),stcons)
- call setstr (16,lintyp(idline))
- call constr (messge(1),lintyp(idline))
- call resstr (lintyp(idline))
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (entry(1),stcons)
- call constr (messge(1),stcons)
- stcons=' have the same coordinat '
- call setstr (25,stcons)
- call constr (messge(1),stcons)
- stcons='es. '
- call setstr (4,stcons)
- call constr (messge(1),stcons)
- call writxt (messge)
- goto 3000
- endif
- if (ierror .eq. 9) then
- stcons=' The '
- call movstr (messge(1),1,0,stcons,1,5)
- call pakstr (messge(1))
- call constr (messge(1),space)
- call setstr (30,linent(idline))
- call constr (messge(1),linent(idline))
- call resstr (linent(idline))
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (entry(1),stcons)
- call constr (messge(1),stcons)
- stcons=' appear twice. '
- call setstr (15,stcons)
- call constr (messge(1),stcons)
- call writxt (messge)
- goto 3000
- endif
- stcons=' Reading '
- call movstr (messge(1),1,0,stcons,1,8)
- if (idparm .eq. 1) then
- call movstr (messge(1),10,0,lintyp(idline),1,16)
- call pakstr (messge(1))
- stcons=' lines '
- call setstr (7,stcons)
- call constr (messge(1),stcons)
- else
- call movstr (messge(1),10,0,linent(idline),1,30)
- call pakstr (messge(1))
- call constr (messge(1),space)
- call wrfstr (entry(1),stcons)
- call constr (messge(1),stcons)
- endif
- stcons=' it was expected to find '
- call setstr(25,stcons)
- call constr(messge(1),stcons)
- if ((idparm .eq. 1) .and. (idline .gt. 7)) then
- stcons=' a '
- else
- stcons=' the '
- endif
- call setstr (5,stcons)
- call constr (messge(1),stcons)
- call pakstr (messge(1))
- call constr (messge(1),space)
- index=itxtpr(idline,idparm)
- call setstr (49,txtpar(index))
- call constr (messge(1),txtpar(index))
- call resstr (txtpar(index))
- call pakstr (messge(1))
- index=itypar(idline,idparm)
- call setstr (14,typpar(index))
- call constr (messge(1),typpar(index))
- call resstr (typpar(index))
- call pakstr (messge(1))
- stcons=' between '
- call setstr (10,stcons)
- call constr (messge(1),stcons)
- call wrfstr (boulow(idline,idparm),stcons)
- call constr (messge(1),stcons)
- stcons=' and '
- call setstr (6,stcons)
- call constr (messge(1),stcons)
- call wrfstr (bouhig(idline,idparm),stcons)
- call constr (messge(1),stcons)
- stcons=' - as the '
- call setstr (11,stcons)
- call constr (messge(1),stcons)
- call setstr (8,ordinl(idparm))
- call constr (messge(1),ordinl(idparm))
- call resstr (ordinl(idparm))
- call pakstr (messge(1))
- stcons=' entry. '
- call setstr (8,stcons)
- call constr (messge(1),stcons)
- call writxt (messge)
- goto 3000
- 1000 write (*,1010)
- 1010 format (//' ERROR : CANNOT READ INPUT FILE.'/
- + ' The program cannot continue.')
- ierror=-1
- goto 3000
- 2000 write (*,2010)
- 2010 format (//' ERROR : CANNOT WRITE OUTPUT FILE.'/
- + ' The program cannot continue.')
- ierror=-1
- 3000 return
- end
- $PAGE
- SUBROUTINE writxt (messge)
- C
- C Write text on the screen formatting to avoid breaking words
- C
- IMPLICIT INTEGER (a-z)
- CHARACTER messge*80,line*79,endwrd*3,space*2
- DIMENSION messge(3)
- line='
- + '
- call setstr (79,line)
- endwrd=' '
- call setstr (3,endwrd)
- space=' '
- call setstr (2,space)
- call expstr (messge(1))
- startp=1
- endtxt=locstr (1,messge(1),endwrd)
- 110 index=startp+79
- IF (ENDTXT .ge. index) THEN
- spcpos=startp-1
- 120 nxtspc=spcpos+1
- length=locstr (nxtspc,messge(1),space)
- IF (length .lt. index) THEN
- spcpos=length
- GOTO 120
- endif
- length=spcpos-startp
- call movstr (line,1,1,messge(1),startp,length)
- call resstr (line)
- write (*,90) line
- 90 format (1x,A79)
- call diskroom (82)
- write (2,90,err=2000) line
- call setstr (79,line)
- startp=spcpos+1
- GOTO 110
- endif
- endtxt=endtxt-1
- call movstr (line,1,1,messge(1),startp,ENDTXT)
- call resstr (line)
- write (*,90) line
- call diskroom (82)
- write (2,90,err=2000) line
- goto 3000
- 2000 write (*,2010)
- 2010 format (//' ERROR : CANNOT WRITE OUTPUT FILE.'/
- + ' The program cannot continue.')
- ierror=-1
- 3000 return
- end
- $PAGE
- FUNCTION degree (oppsid,closid)
- C
- C Determine angle in degrees with opposite and next side of triangle.
- C
- IF (abs(closid) .gt. 1e-19) THEN
- degree=57.2957795*ATAN(oppsid/closid)
- IF (closid .LT. 0.) degree=degree+180.
- IF (degree .gt. 180.) degree=degree-360.
- ELSE
- IF (oppsid .ge. 0.) then
- degree=90.
- else
- degree=-90.
- endif
- ENDIF
- RETURN
- END
- $PAGE
- SUBROUTINE datstr(string)
- C
- C Write the date in a string.
- C
- IMPLICIT integer (a-z)
- CHARACTER string*11,blank*2,buffer*10
- call date (day,month,year)
- write (buffer,10) month,day,year
- 10 FORMAT (i2,'/',i2,'/',i4)
- READ (buffer,20) string
- 20 format (a10)
- call setstr (11,string)
- asciic=ascstr(4,string)
- if (asciic .eq. 32) call modstr (string,4,48)
- RETURN
- END
- $PAGE
- SUBROUTINE timstr(string)
- C
- C Write the time-of-day in a string.
- C
- IMPLICIT integer (a-z)
- real realsc
- CHARACTER string*12,blank*2,buffer*11
- call time (hour,minute,second,sec100)
- realsc=float(second)+float(sec100)/100.
- write (buffer,10) hour,minute,realsc
- 10 FORMAT (i2,':',i2,':',f5.2)
- READ (buffer,20) string
- 20 format (a11)
- call setstr (12,string)
- asciic=ascstr(4,string)
- if (asciic .eq. 32) call modstr (string,4,48)
- asciic=ascstr(7,string)
- if (asciic .eq. 32) then
- call modstr (string,7,48)
- asciic=ascstr(8,string)
- if (asciic .eq. 32) call modstr (string,8,48)
- endif
- RETURN
- END
- $PAGE
- FUNCTION fltstr (string)
- C
- C Calculate the floating point value of a string.
- C
- CHARACTER buffer*26,string*25
- write (buffer,*) string
- READ (buffer,10,ERR=300) intstr
- 10 format (bn,i25)
- fltstr=float(intstr)
- goto 500
- 300 fltstr=0
- READ (buffer,310,ERR=500) fltstr
- 310 format (bn,f25.0)
- 500 RETURN
- END
- $PAGE
- SUBROUTINE wrfstr (real,string)
- C
- C Write a real in a string.
- C
- implicit integer (a-z)
- real real
- CHARACTER string*25,expnnt*5
- if (real .eq. 0.) then
- string='0 '
- call setstr (25,string)
- call endstr (2,string)
- else
- if ((abs(real) .ge. 1.e11) .or. (abs(real) .lt. 1.e-5)) then
- write (string,10) real
- 10 format (E12.6E2)
- call setstr (25,string)
- call pakstr (string)
- expnnt='E '
- call setstr (5,expnnt)
- call endstr (2,expnnt)
- l=locstr (1,string,expnnt)
- call movstr (expnnt,1,1,string,l,4)
- 30 l=l-1
- if (ascstr(l,string) .eq. 48) goto 30
- call movstr (string,l+1,1,expnnt,1,4)
- else
- write (string,40) real
- 40 format (F19.10)
- call setstr (25,string)
- call pakstr (string)
- l=lenstr (string)+1
- 50 l=l-1
- if (ascstr(l,string) .eq. 48) goto 50
- if (ascstr(l,string) .eq. 46) l=l-1
- call endstr (l+1,string)
- endif
- endif
- RETURN
- END
-